Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/boxes/demo2/aboutbox.bas

BASIC Source File | 1995-03-30 | 6KB | 145 lines

Option Explicit
' Any program that includes this file must also include ABOUTBOX.TXT
' and ABOUTBOX.FRX
' The AB_NO_xxxx constants are used to exclude informational lines
' from the About Box display.  You pass one or more of them, combined
' using OR, as the last parameter to DisplayAboutBox.
Global Const AB_NO_USER = &H1
Global Const AB_NO_COMPANY = &H2
Global Const AB_NO_WINVER = &H4
Global Const AB_NO_DOSVER = &H8
Global Const AB_NO_WINMODE = &H10
Global Const AB_NO_MEMORY = &H20
Global Const AB_NO_80x87 = &H40
Global Const AB_NO_FSR = &H80

Global Excl% ' Global variable holds bit flags for excluded items.

' GetSystemMetrics returns the size (in pixels) of various on-screen
' items.  There are many more SM_xxxx constants besides those defined
' below.  The About Box uses the sizes to set its position on screen.
Declare Function GetSystemMetrics% Lib "User" (ByVal nIndex%)
Global Const SM_CYCAPTION = &H4
Global Const SM_CYMENU = &HF
Global Const SM_CXSIZE = &H1F

' API functions used in getting user and company name
Declare Function LoadLibrary% Lib "Kernel" (ByVal LibFileName$)
Declare Sub FreeLibrary Lib "Kernel" (ByVal hInst%)
Declare Function LoadString% Lib "User" (ByVal hInst%, ByVal idResource%, ByVal Buffer$, ByVal cBuffer%)

' GetVersion returns both Windows and DOS versions
Declare Function GetVersion& Lib "Kernel" ()

' GetWinFlags returns a Long that's filled with bit-flags providing
' information about Windows.  We use only 3 of its 13 flags
Declare Function GetWinFlags& Lib "Kernel" ()
Global Const WF_PMODE = &H1
Global Const WF_ENHANCED = &H20
Global Const WF_80x87 = &H400

' GetFreeSpace returns the amount of free memory
Declare Function GetFreeSpace& Lib "Kernel" (ByVal wFlags%)

' Free System Resources are a special kind of memory that can run out
' before your main memory runs out.
Declare Function GetFreeSystemResources% Lib "User" (ByVal fuSysResource%)
Global Const GFSR_SYSTEMRESOURCES = 0
Global Const GFSR_GDIRESOURCES = 1
Global Const GFSR_USERRESOURCES = 2

Sub DisplayAboutBox (F As Form, ByVal ProgName$, ByVal Version, ByVal CoprDate, ByVal CoprName$, ByVal Ex1$, ByVal Ex2$, ByVal Exclude%, ByVal Center%, ByVal Fore&, ByVal Back&)
'Your program simply calls this function to display an about box.
'F         - the main form of the calling program, used to get an
'            icon for display and to position the about box.
'ProgName  - program name, for caption and first line
'Version   - version number, displayed as 0.00
'CoprDate  - copyright year
'CoprName  - copyright holder's name
'Ex1       - extra data line 1 (optional)
'Ex2       - extra data line 2 (optional)
'Exclude   - used to exclude info from the about box.  AB_NO_xxxx
'            constants are bit-flags for this parameter.  e.g. to
'            exclude displaying DOS & Windows versions, pass
'            AB_NO_DOSVER OR AB_NO_WINVER
'Center    - if TRUE, About box is centered on screen; if FALSE, About
'            box is displayed offset from calling window.
'Fore,Back - foreground and background colors for box; 0 to use default
  Excl = Exclude
  Load FAB
  Dim N%
  If Fore Then
    FAB.ForeColor = Fore
    FAB.CoprLabel.ForeColor = Fore
    FAB.MyInfoLabel.ForeColor = Fore
    FAB.NameLabel.ForeColor = Fore
    For N = 0 To 14
      FAB.OptLabel(N).ForeColor = Fore
    Next N
    FAB.Shape1.BorderColor = Fore
  End If
  If Back Then
    FAB.BackColor = Back
    FAB.CommandOK.BackColor = Back
    FAB.CoprLabel.BackColor = Back
    FAB.IconPicture.BackColor = Back
    FAB.NameLabel.BackColor = Back
    FAB.MyInfoLabel.BackColor = Back
    FAB.Shape1.FillColor = Back
    For N = 0 To 14
      FAB.OptLabel(N).BackColor = Back
    Next N
  End If
  If Center Then
    FAB.Left = (Screen.Width - FAB.Width) \ 2
    FAB.Top = (Screen.Height - FAB.Height) \ 2
  Else
    ' Place the About box over the calling window, offset downward
    ' and to the right
    Dim Tmp% ' variable to keep lines of code from becoming TOO long
    Tmp = GetSystemMetrics(SM_CXSIZE)
    FAB.Left = F.Left + Tmp * Screen.TwipsPerPixelX
    Tmp = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYMENU)
    FAB.Top = F.Top + Tmp * Screen.TwipsPerPixelY
    ' If about box now extends off the screen, move it back ON
    If FAB.Left + FAB.Width > Screen.Width Then
      FAB.Left = Screen.Width - (FAB.Width + 30)
    End If
    If FAB.Top + FAB.Height > Screen.Height Then
      FAB.Top = Screen.Height - (FAB.Height + 30)
    End If
  End If
  FAB.IconPicture.Picture = F.Icon
  FAB.Caption = "About " + ProgName$
  Dim Temp$ ' variable to keep lines of code from becoming TOO long
  Temp = ProgName$ + ", Version " + Format$(Version, "0.00")
  FAB.NameLabel.Caption = Temp
  Temp = "Copyright ⌐ " + CoprDate + " by " + CoprName
  FAB.CoprLabel.Caption = Temp
  If Ex1 = "" Then
    EliminateLabel 0
  Else
    FAB.OptLabel(0).Caption = Ex1
  End If
  If Ex2 = "" Then
    EliminateLabel 1
  Else
    FAB.OptLabel(1).Caption = Ex2
  End If
  FAB.Show
End Sub

Sub EliminateLabel (ByVal Which%)
  ' If one of the informational labels in the about box is not wanted,
  ' make it invisible and move all the other labels up to fill in the
  ' space.  Then shrink the form as well.
  FAB.OptLabel(Which).Visible = False
  Dim N%, H%
  H = FAB.OptLabel(0).Height
  For N = Which + 1 To 14
    FAB.OptLabel(N).Top = FAB.OptLabel(N).Top - H
  Next N
  FAB.Height = FAB.Height - H
End Sub